perm filename PHE.VLI[VLI,LSP] blob
sn#379953 filedate 1978-09-08 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00022 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 init
C00021 00003 while
C00033 00004 eq null nextl setq cond
C00040 00005 testarg mc1 testa test3 init props meval qqc
C00048 00006 wht wht1
C00056 00007 nimmarg combc pusc pob
C00059 00008 pprin test
C00061 00009 eqq
C00066 00010 erftn add getarg but unput
C00072 00011 kond kondk fsub iprog
C00077 00012 ade errgrave aux aux1 predic
C00079 00013 aehnlich trr
C00084 00014 erreur eti etiq1 etiq2 ervarl ervara varan
C00089 00015 cond0 cond1 cond2 cond3
C00097 00016 getall finconv find1 find2 hypval null1 caddar
C00100 00017 delete insert insert1 test1 test2
C00103 00018 PHENAR----
C00106 00019 rec -rec4 com
C00108 00020 meval2 rec1 shorter longer greater smaller
C00111 00021 meval1
C00115 00022 find rec2 rec22 rec3 gettyp insert2
C00123 ENDMK
C⊗;
; init ;
(SETQ P 'PHENARETES)
(SETQ NULL)
(SETQ FFNVAR)
(SETQ REFAV)
(SETQ LABEL)
(SETQ VARLOC)
(SETQ FFN)
(DMC /ε () ['PHENARETES[quote (READ)]])
(DE INIT1 ()
(SETQ F-N-SUBR)
(SETQ %%C)
(SETQQ QQC QQC)
(SETQQ
%%1
(LOOPVAR ICOND IPROG RETRN %LLL1 %LLL2 FIND MODIF TYP VAL
LCOND %LLL3 WHT HELP))
(MAPC '(PLUS ADD1 SUB1 DIFFER)
'(LAMBDA (-X) (PUT -X 0 'NEUTRE)))
(MAPC '(TIMES QUO REM) '(LAMBDA (-X) (PUT -X 1 'NEUTRE)))
(MAPC
'(TERPRI CLRBIT SETBIT PRINT NEXTL PRIN1 SPACES EVAL PAGE GO GOTO
SETQ APPLY RPLACA RPLACD MAPC MAP NCONC SET PUT PROGN COND AND
OR WHILE ESCAPE RETURN) '(LAMBDA (-X) (PUT -X T 'TOPL)))
(MAPC '(NEXTL SETQ RPLACA RPLACD NCONC1 NCONC SET PUT)
'(LAMBDA (-X) (PUT -X T 'PHYS)))
(MAPC
'(CAR CDR CAAR CDAR CADR CDDR CADDR CADAR CAADR CADADR LENGTH
REVERSE CAADDR CADADDR CADDDR CDDDR NEXTL NCONC APPEND)
'(LAMBDA (-X) (PUT -X 'LISTP 'ARG1)))
(MAPC
'(ADD1 GTZ SUB1 ZEROP PAGE SWITCH SPACES DIFFER TIMES QUO PLUS
REM 1+ 1- * + GT GE LT LE NTH)
'(LAMBDA (-X) (PUT -X 'NUMBP 'ARG1)))
(MAPC '(QUO TIMES PLUS REM * + DIFFER GT GE LT LE)
'(LAMBDA (-X) (PUT -X 'NUMBP 'ARG2)))
(MAPC '(GO EQ NEQ MEMQ) '(LAMBDA (-X) (PUT -X 'ATOM 'ARG1)))
(MAPC '(ADD1 SUB1 LENGTH DIFFER QUO REM TIMES PLUS * + 1+ 1-)
'(LAMBDA (-X) (PUT -X 'NUMBP 'VAL)))
(MAPC
'(CDR REVERSE CDAR CDDR CONS NTH NCONC1 NCONC OBLIST APPEND SUBST
LIST) '(LAMBDA (-X) (PUT -X 'LISTP 'VAL)))
(MAPC '(PUT GENSYM ATOM ZEROP GT LT LE GE GZP GTZ)
'(LAMBDA (-X) (PUT -X 'ATOM 'VAL)))
(MAPC '(OBLIST GENSYM READ TERPRI)
'(LAMBDA (-X)
(PUT -X 0 'NUMARG)
(SETQ F-N-SUBR (CONS -X F-N-SUBR))))
(MAPC
'(CLRBIT SETBIT QUOTE ADD1 EVLIS EPROGN ATOM PLENGTH TTAB GZP CAR
1+ 1- CDR NOT NULL GTZ NUMBP SUB1 LENGTH REVERSE CAAR CDAR CADR
CDDR CADDR CADAR CAADR CADADR CAADDR CADADDR CADDDR LISTP ZEROP
PRINT NEXTL PRIN1 SPACES EVAL PAGE GO GOTO SWITCH)
'(LAMBDA (-X) (PUT -X 1 'NUMARG) (NCONC1 F-N-SUBR -X)))
(MAPC
'(SETQ APPLY RPLACA RPLACD CONS EQ NEQ GET DIFFER REM QUO GT GE
LT LE NTH MAPC MAP NCONC1 NCONC MEMQ LOGAND LOGOR LOGSHIFT
APPEND EQUAL SET ASSQ CASSQ)
'(LAMBDA (-X) (PUT -X 2 'NUMARG) (NCONC1 F-N-SUBR -X)))
(PUT 'IF 3 'NUMARG)
(PUT 'PUT 3 'NUMARG)
(PUT 'SUBST 3 'NUMARG)
(MAPC
'(PROGN COND TIMES PLUS AND OR WHILE PROG DF DE ESCAPE QUOTE *
+ STATUS RETURN LIST)
'(LAMBDA (-X) (PUT -X 4 'NUMARG) (NCONC1 F-N-SUBR -X)))
(NCONC1 F-N-SUBR 'IF)
(NCONC1 F-N-SUBR 'PUT)
(NCONC1 F-N-SUBR 'SUBST)
(MAPC
'(NOT NULL GTZ NUMBP LISTP ZEROP SWITCH EQ NEQ GT GE LT LE ATOM
MEMQ EQUAL OR AND) '(LAMBDA (-X) (PUT -X 'PREDICAT 'TYP)))
(MAPC '(MEMQ NCONC NCONC1 CONS NTH APPEND)
'(LAMBDA (-X) (PUT -X 'LISTP 'ARG2)))
(MAPC '(EQ NEQ) '(LAMBDA (-X) (PUT -X 'ATOM 'ARG2)))
(PUT 'COND '(LAMBDA -X (COND0 -X)) 'FTN)
(PUT 'CAR 'UN 'VAL)
(PUT 'RETURN
(FUNCTION (LAMBDA -X
(IF (NULL IPROG)
(PROGN
(SETQ IPROG T)
(RPLACD (CDDR AUX)
[(APPEND '(PROG NIL) (CDDDR AUX))])
(PRINT "ERREUR :" !!
"RETURN NE PEUT ETRE UTILISE"
"L'INTERIEUR D'UN PROG"))
(PROGN
(MAPC -X
(FUNCTION (LAMBDA (XX)
(COND
((EQ (CAR XX) 'GO)
(PRINT "ERREUR :" !!
"JE NE COMPRENDS PAS VOTRE INTENTION"
"DANS"
(CONS 'RETURN -X)))
((MEVAL XX))))))
(SETQ RETRN (UNION VAL RETRN))))))
'FTN1)
(PUT 'DE
(FUNCTION (LAMBDA -X
(COND
((OR FFN IPROG) (ERRGRAVE 'DE -X))
(T (WHILE (LISTP (CAR -X))
(SETQ -X (APPEND (CAR -X) (CDR -X))))
(SETQ FFN (CAR -X))
(RPLACD FFN NIL)
(OR (MEMQ FFN F-N-SUBR) (NEWL F-N-SUBR FFN))
(SETQ %LLL1 (CAR (LAST -X)))
(ADD 'DE)
(ADD FFN)
(VARAN (ERVARL (CDR -X)) 'FFNVAR)
(PUT FFN FFNVAR 'DUVAR)
(PUT FFN (LENGTH FFNVAR) 'NUMARG)
(ADD FFNVAR)
(NIMMARG -X)
(AND (NUMBP %LLL2) (EQ %LLL1 %LLL2) (ADD %LLL1))
(SETQ AUX (REVERSE AUX))
(ADE)))))
'FTN)
(PUT 'CONS
(FUNCTION (LAMBDA -X
(SETQ YY '(ARG1 ARG2))
(INCR PROFO)
(NEWL %LLL3 'CONS)
(MEVAL (CAR -X))
(PUSH HYPVAL)
(PUSC VAL)
(INCR PROFO)
(MEVAL (CADR -X))
(NEXTL %LLL3)
(COND
((EQ TYP 'UN)
(COND
((NULL (CADR -X)))
((ATOM (CADR -X)) (PUT (CADR -X) 'LISTP 'TYP))
((EQ (CAADR -X) FFN) (PUT FFN 'LISTP 'VAL))))
((OR (EQ TYP 'ATOM) (EQ TYP 'NUMBP))
(PRINT "ATTENTION ! DANS " (CONS 'CONS -X)
"LE DEUXIEME ARGUMENT EST ATOMIQUE")
(PROPS ['CONS (CAR -X) ['LIST (CADR -X)]])))
(SETQ
VAL
(COND
((NULL VAL)
(COND
((EQ (CAR STACK) 'NILL) (NEXTL STACK) NIL)
((NULL (CAR STACK)) (NEXTL STACK))
((ATOM (CAR STACK)) [(NEXTL STACK)])
((NEXTL STACK))))
((EQ VAL 'NILL)
(COND
((EQ (CAR STACK) 'NILL)
(NEXTL STACK)
(CONS))
((NULL (CAR STACK)) (NEXTL STACK))
((CONS (NEXTL STACK)))))
((ATOM VAL)
(COND
((NULL (CAR STACK)) (NEXTL STACK) [VAL])
((EQ (CAR STACK) 'NILL)
(NEXTL STACK)
[NIL VAL])
([(NEXTL STACK) VAL])))
((NULL (CAR STACK)) (NEXTL STACK) VAL)
((EQ (CAR STACK) 'NILL)
(NEXTL STACK)
(CONS NIL VAL))
((CONS (NEXTL STACK) VAL))))
(SETQ TYP 'LISTP HYPVAL (CONS (POP) HYPVAL))
(SETQ MODIF 'LONGER)
(IF (GZP PROFO)
(DECR PROFO)
(ERREUR 'NIVEAU (CONS 'CONS -X)))))
'FTN1)
(PUT 'IF
(FUNCTION (LAMBDA -X
(INSERT ['COND [(CAR -X) (CADR -X)] [T (CADDR -X)]]
(CONS 'IF -X) T)))
'FTN1)
(PUT 'QUOTE
(FUNCTION (LAMBDA -X
(IF (ATOM (CAR -X)) (SETQ TYP 'ATOM) (SETQ TYP 'LISTP))
(AND
(OR
(MEMQ (CAR -X) '(NIL T EXPR FEXPR LAMBDA))
(NUMBP (CAR -X)))
(INSERT (CAR -X) (CONS QUOTE -X) T))
(SETQ VAL (CAR -X) HYPVAL (CAR -X))
(IF (ZEROP PROFO)
(ERREUR 'NIVEAU (CONS QUOTE -X))
(DECR PROFO))))
'FTN1)
(PUT 'PROG
(FUNCTION (LAMBDA -X
(COND
(IPROG (ERRGRAVE 'PROG -X))
((SETQ IPROG T)
(VARAN (ERVARL -X) 'VARLOC)
(PUSC AUX)
(SETQ AUX)
(AND FFN (PUT FFN VARLOC 'VARLOC))
(ADD 'PROG)
(ADD VARLOC)
(NIMMARG -X T)
(SETQ AUX (REVERSE AUX))
(IPROG)
(PUSC AUX)
(SETQ AUX (CADR STACK))
(ADD (POB))
(POB)
(OR FFN (SETQ AUX (CAR AUX)))))))
'FTN)
(PUT 'GO
(FUNCTION (LAMBDA -X
(COND
((ATOM (CAR -X))
(AND (NUMBP (CAR -X)) (RPLACA -X (ETI (CAR -X))))
(COND
((MEMQ (CAR -X) LABEL) (PUT (CAR -X) T 'AP))
((MEMQ (CAR -X) REFAV))
((SETQ REFAV (CONS (CAR -X) REFAV))
(PUT (CAR -X) T 'AP)))
(ADD ['GO (CAR -X)])
(NEXTL HELP))
((OR (MEMQ (CAAR -X) F-N-SUBR) (EQ (CAR -X) FFN))
(ERRGRAVE 'GO -X))
(T (APPLY (GET 'GO 'FTN) (APPEND (CAR -X) (CDR -X)))))
T))
'FTN)
(PUT 'OR '(LAMBDA -X (FSUB -X 'OR)) 'FTN)
(PUT 'STATUS '(LAMBDA -X (FSUB -X 'STATUS)) 'FTN)
(PUT 'AND '(LAMBDA -X (FSUB -X 'AND)) 'FTN)
(PUT 'LIST '(LAMBDA -X (FSUB -X 'LIST)) 'FTN)
(PUT 'TIMES '(LAMBDA -X (FSUB -X 'TIMES)) 'FTN)
(PUT 'PLUS '(LAMBDA -X (FSUB -X 'PLUS)) 'FTN)
(PUT 'RETURN '(LAMBDA -X (FSUB -X 'RETURN)) 'FTN)
(PUT 'WHILE '(LAMBDA -X (FSUB -X 'WHILE)) 'FTN)
(PUT 'PROGN '(LAMBDA -X (FSUB -X 'PROGN)) 'FTN)
(PUT QUOTE
'(LAMBDA -X
(ADD (CONS QUOTE (IF (GT (LENGTH -X) 1) [-X] -X)))
(NEXTL HELP))
'FTN)
(PUT 'DE
'(LAMBDA -X
(AND IBEISP (IBEISP (CADR -X)))
(MAPC (CDDR -X) 'MEVAL)
(PUT FFN TYP 'VAL)
(SETQ AUX1 '(ARG1 ARG2 ARG3))
(MAPC (GET FFN 'DUVAR)
(FUNCTION (LAMBDA (XX)
(PUT FFN (GET XX 'TYP) (NEXTL AUX1))))))
'FTN1)
(PUT 'PROG
(FUNCTION (LAMBDA -X
(PUSC PROFO)
(SETQ PROFO 0)
(MAPC (CDR -X) 'MEVAL)
(SETQ PROFO (POB))
(OR (ZEROP PROFO) (DECR PROFO))
(AND RETRN (SETQ VAL RETRN))))
'FTN1)
(PUT 'PRINT '(LAMBDA (-X) (INCR PROFO) (MEVAL -X)) 'FTN1)
(PUT 'GTZ
'(LAMBDA (-X)
[['SETQ -X ['SUB1 -X]] ['SETQ -X ['DIFFER -X 'QQC]]])
'WHT)
(PUT 'GE
'(LAMBDA (-X Y)
[['SETQ -X ['SUB1 -X]]
['SETQ Y ['ADD1 Y]]
['SETQ -X ['DIFFER -X 'QQC]]
['SETQ Y ['PLUS Y 'QQC]]])
'WHT)
(PUT 'LE
'(LAMBDA (-X Y)
[['SETQ -X ['ADD1 -X]]
['SETQ Y ['SUB1 Y]]
['SETQ -X ['PLUS -X 'QQC]]
['SETQ Y ['DIFFER Y 'QQC]]])
'WHT)
; while ;
(PUT 'WHILE
(FUNCTION (LAMBDA -X
(PUSC PROFO)
(SETQ PROFO 1)
(MEVAL (CAR -X))
(PUSC TYP)
(PUSC VAL)
(COND
((MEMQ (CAAR -X) '(GT GE LT LE))
(COND
((OR (NUMBP (CADAR -X)) (NUMBP (CADDAR -X))) )
(T (NEWL %LLL3 (CAAR -X))
(MEVAL (CADAR -X))
(NEWL WHT2 HYPVAL)
(MEVAL (CADDAR -X))
(NEXTL %LLL3)
(NEWL WHT2
(EVAL ['DIFFER (NEXTL WHT2) HYPVAL])))))
((AND
(MEMQ (CAAR -X) '(NULL NOT))
(EQ (CAR (CADR (CAR -X))) 'ZEROP))
(NEWL %LLL3 'ZEROP)
(MEVAL (CADR (CADR (CAR -X))))
(NEXTL %LLL3)
(NEWL WHT2 HYPVAL)))
(AND
(ATOM (CAR -X))
(NEWL WHT (CAR -X))
(EQ TYP 'UN)
(PUT (CAR -X) 'LISTP 'TYP))
(MAPC (CDR -X) 'MEVAL)
(SETQ VAL (POB) TYP (POB) PROFO (POB))
(SETQ AUX1 NIL)
(IF (LISTP (CAR -X)) (COMBC (CAR -X)))
(COND
((OR (NULL (CAR -X)) (EQ VAL 'NILL))
(PRINT "CA VA PAS PTITE TETE ...")
(PRETTYP (CONS 'WHILE -X)))
((OR (EQ TYP 'NUMBP) (EQ VAL T))
(ERREUR "CA BOUCLE" (CONS 'WHILE -X)))
(AUX1 (WHT AUX1 -X))
(T (WHT (CAR -X) (CDR -X))
(COND
(WHT2
(ESCAPE EX
(SETQ YY '(ARG1 ARG2))
(NEWL %LLL3 (CAAR -X))
(IF (MEMQ (CAAR -X) '(NOT NULL))
(MEVAL (CADR (CADR (CAR -X))))
(MEVAL (CADR (CAR -X))))
(NEWL WHT2 HYPVAL)
(IF (MEMQ (CAAR -X) '(NULL NOT)) (EX))
(MEVAL (CADDAR -X))
(NEXTL %LLL3)
(NEWL WHT2
(EVAL ['DIFFER (NEXTL WHT2) HYPVAL]))
(NEWL WHT2
(DIFFER (NEXTL WHT2) (NEXTL WHT2))))
(SELECTQ
(OR
(AND
(MEMQ (CAAR -X) '(NULL NOT))
(EQ (CAR (CADR (CAR -X))) 'ZEROP)
'ZEROP)
(CAAR -X))
((GT GE)
(IF (GE (NEXTL WHT2) 0)
(PROGN
(SETQ
HELP
(COND
((COMBC (CADAR -X))
(CAR
( (GET (CAAR -X)
'WHT) AUX1)))
((COMBC (CADDR (CAR -X)))
(CADR
( (GET (CAAR -X)
'WHT) AUX1)))))
(AND
HELP
(INSERT1 HELP
(CONS 'WHILE -X))))))
((LE LT)
(IF (GZP (NEXTL WHT2))
NIL
(SETQ
HELP
(COND
((COMBC (CADAR -X))
(CAR
((GET (CAAR -X) 'WHT)
AUX1)))
((COMBC (CADDR (CAR -X)))
(CADR
((GET (CAAR -X) 'WHT)
AUX1)))))
(AND
HELP
(INSERT1 HELP (CONS 'WHILE -X)))))
(ZEROP
(NEWL WHT2
(DIFFER (CAR WHT2) (CADR WHT2)))
(COND
((GZP (CADR WHT2))
(COND
((EQ (CAR WHT2) -1) NIL)
((ZEROP (CAR WHT2))
(COMBC (CADR (CADAR -X)))
(IF AUX1
(INSERT1
['SETQ
AUX1
['SUB1 AUX1]]
(CONS 'WHILE -X))))
((LT (CAR WHT2) 0)
(COND
((ZEROP
(REM (CADR WHT2)
(DIFFER
0
(CAR WHT2)))) )
(T (PRINT "DANS"
(CONS 'WHILE -X)
"VOUS NE TOMBER JAMAIS"
"SUR ZERO")
(INSERT1
['SETQ
AUX1
['SUB1 AUX1]]
(CONS 'WHILE -X)))))
(T (ERREUR "CA BOUCLE"
(CONS 'WHILE -X))))
(SETQ WHT2 (CDDR WHT2)))))(nil))))))
(AND (GZP PROFO) (DECR PROFO))
(AND
(OR
(AND (ATOM (CAR -X)) (SETQ AUX1 (CAR -X)))
(COMBC (CAR -X)))
(IF
(OR
(AND (GET AUX1 'VAL) (EQ (GET AUX1 'VAL) VAL))
(EQ (GET AUX1 'VALAT) AUX1))
(PROGN
(ERREUR "CA RISQUE DE BOUCLER"
(CONS 'WHILE -X))
(FIND1 AUX1 (CDR -X))
(INSERT AUX4 AUX1 T NIL NIL AUX3 T))
T)
(NEXTL WHT))
(SETQ VAL 'NILL TYP 'UN HYPVAL 'NILL)))
'FTN1)
; eq null nextl setq cond ;
(PUT 'EQ '(LAMBDA (-X Y) (EQQ -X Y)) 'FTN1)
(PUT 'NULL
(FUNCTION (LAMBDA (-X)
(COND
((NULL -X) (INSERT T ['NULL -X] T))
((MEMQ -X WHT)
(PRINT "CA VA PAS , PTITE TETE ...:" ['NULL -X])
(INSERT NIL ['NULL -X] T))
((OR (NUMBP -X) (EQ -X T))
(INSERT NIL ['NULL -X] T))
((INCR PROFO)
(MEVAL -X)
(COND
((OR (EQ TYP 'NUMBP) (AND VAL (LITATOM VAL)))
(PRINT "ATTENTION DANS" ['NULL -X] -X
"N'EST PAS UNE LISTE"))
((EQ VAL 'NILL) (SETQ VAL T TYP 'ATOM))
((NULL VAL)
(IF (ATOM -X) (PUT -X 'LISTP 'TYP))
(SETQ TYP 'LISTP))
((SETQ TYP 'UN VAL 'NILL)
(IF (ATOM -X) (PUT -X 'LISTP 'TYP))))))
(SETQ HYPVAL (NULL1 HYPVAL))
(IF (ZEROP PROFO)
(ERREUR "NIVEAU" ['NULL -X])
(DECR PROFO))))
'FTN1)
(PUT 'NEXTL
(FUNCTION (LAMBDA (-X)
(ESCAPE EXIT
(SETQ MODIF)
(AND
(NULL -X)
(SETQ VAL 'NILL HYPVAL 'NILL)
(IF (ZEROP PROFO)
(DELETE ['NEXTL -X])
(INSERT -X ['NEXTL -X] T))
(EXIT))
(INCR PROFO)
(NEWL %LLL3 'NEXTL)
(MEVAL -X)
(NEXTL %LLL3)
(AND
(EQ VAL 'NILL)
(EXIT (SETQ TYP 'UN HYPVAL 'NILL)))
(AND (EQ TYP 'UN) (ATOM -X) (BUT -X 'LISTP 'TYP))
(COND
((EQ TYP 'LISTP)
(AND VAL (BUT -X (CDR VAL) 'VAL))
(AND (ATOM -X) (PUT -X 'SHORTER 'MODIF)))
((EXIT
(ERREUR
"NEXTL N'ADMET PAS DES ARGUMENTS A VALEUR"
"ATOMIQUE"
['NEXTL -X]))))
(SETQ
TYP
(COND
(VAL (TYPEP (SETQ VAL (CAR VAL))))
('UN)))
(IF (AND (NEQ VAL 'NILL) VAL)
(SETQ HYPVAL VAL)
(SETQ HYPVAL (CAR HYPVAL)))
(AND (EQ TYP 'LITATOM) (SETQ TYP 'ATOM)))))
'FTN1)
(PUT 'COND '(LAMBDA -X (KOND -X)) 'FTN1)
(PUT 'SETQ
(FUNCTION (LAMBDA -X
(SETQ MODIF)
(COND
((LISTP (CAR -X))
(INSERT (CONS 'SET -X) (CONS 'SETQ -X) T)
(PRINT
"SETQ N'EVALUE PAS SON PREMIER ARGUMENT, JE CHANGE"
!! '(!? 10) (CONS 'SETQ -X) !! "EN" !! '(!? 10)
(CONS 'SET -X)))
((OR
(NUMBP (CAR -X))
(EQ (CAR -X) (CADR -X))
(MEMQ (CAR -X) '(NIL T EXPR FEXPR LAMBDA)))
(IF (ZEROP PROFO)
(DELETE (CONS 'SETQ -X))
(INSERT (CADR -X) (CONS 'SETQ -X) T))
(PRINT "J'ENLEVE" (CONS 'SETQ -X)))
((INCR PROFO)
(MEVAL (CADR -X))
(IF (ATOM (CADR -X))
(BUT (CAR -X)
(OR (GET (CADR -X) 'VALAT) (CADR -X)) 'VALAT)
(BUT (CAR -X) NIL 'VALAT))
(BUT (CAR -X) HYPVAL 'HYPVAL)
(BUT (CAR -X) VAL 'VAL)
(BUT (CAR -X) TYP 'TYP)
(BUT (CAR -X) MODIF 'MODIF)))
(AND (GZP PROFO) (DECR PROFO))))
'FTN1)
(RPLACD 'PRIN1 (CDR 'PRINT))
(RPLACD 'GT (CDR 'GE))
(RPLACD 'GZP (CDR 'GTZ))
(RPLACD '+ (CDR 'PLUS))
(RPLACD '* (CDR 'TIMES))
(RPLACD '1- (CDR 'SUB1))
(RPLACD '1+ (CDR 'ADD1))
(RPLACD 'LT (CDR 'LE)))
(INIT1)
(rplacd 'init1)
(STATUS 2 27)
(SETQQ !! (!!))
(DMO !! () (TERPRI))
(DMO !? (N) (SPACES N))
; testarg mc1 testa test3 init props meval qqc ;
(DE TESTARG (-X Z ZZ WW)
(SETQ YY '(ARG1 ARG2 ARG3))
(SETQ ZZ (MEMQ (CAR -X) F-N-SUBR))
(SETQ
WW
(MAPCAR (IF ZZ (CDR -X) -X)
(FUNCTION (LAMBDA (XX)
(INCR PROFO)
(IF (AND ZZ (LISTP XX) (EQ (CAR XX) FFN))
(SETQ %LLL3 (CONS (CAR ZZ) %lll3)))
(MEVAL XX)
(PUSH HYPVAL)
(AND ZZ (LISTP XX) (EQ (CAR XX) FFN) (NEXTL %LLL3))
(AND
YY
ZZ
(SETQ Z (CAR YY))
(COND
((NULL TYP))
((NULL (SETQ Z (GET (CAR -X) Z))))
((EQ TYP Z))
((ATOM XX)
(COND
((AND (EQ Z 'ATOM) (EQ TYP 'NUMBP)))
((IF (EQ TYP 'UN)
(PUT XX Z 'TYP)
(TESTA -X (CAR YY) XX Z TYP)))))
((EQ TYP 'UN))
((TESTA -X (CAR YY) XX Z TYP))))
(NEXTL YY)
(POP)))))
(AND
ZZ
(SETQ VAL NIL TYP (GET (CAR -X) 'VAL T T))
(SETQ
HYPVAL
(COND
((MEMQ (CAR ZZ) '(SUB1 ADD1))
(IF (NUMBP HYPVAL) (EVAL [(CAR ZZ) HYPVAL])))
((MEMQ (CAR ZZ) '(PLUS DIFFER TIMES))
(IF (MC1 WW 'NUMBP) (EVAL (CONS (CAR ZZ) WW))))))))
(DE MC1 (-X F)
(ESCAPE EX
(COND
((NULL -X) NIL)
((F (CAR -X)) (CONS (CAR -X) (MC1 (CDR -X) F)))
((EX)))))
(DE TESTA (-X YY XX Z TYP)
(PRINT "ERREUR :" !! "DANS " -X YY ":" XX "DOIT ETRE DU TYP" Z !!
"ICI C'EST DU TYP" TYP))
(DE INIT (-X)
(OR -X (SETQ REC))
(MAPC FFNVAR 'RPLACD)
(MAPC FFNVAR 'SET)
(MAPC VARLOC 'SET)
(MAPC VARLOC 'RPLACD)
(MAPC LABEL 'RPLACD)
(MAPC REFAV 'RPLACD)
(IF -X NIL (SETQ TEST1 1))
(SETQ
AVANCE '(CDR CAR CDDR CADR CAAR CDAR CDDDR CADDR CADAR))
(MAPC
'(FFN FFNVAR REFAV LOOPVAR ICOND IPROG VARLOC LABEL RETRN %LLL1
%LLL3 HYPVAL HYPO WHT2 %LLL2 IBEISP HELP1 FIND WHT MODIF TYP
VAL LCOND AUX HELP STACK) 'SET)
(SETQ PROFO 0))
(DE CONVERSATION () (SETQ %%C T))
(DE UNION (-X Y) (IF (MEMBER -X Y) Y (CONS -X Y)))
(DE PROPS (-X)
(PRINT "IL VAUDRAIT PEUT-ETRE MIEUX ECRIRE :")
(TTAB 10)
(PRINT -X !!))
(DE MEVAL (-X)
(AND
(LISTP -X)
(ATOM (CAR -X))
(MEMQ (CAR -X)
'(TIMES PLUS ADD1 1+ 1- CONS CDR CAR CDDR QUO REM CDDDR))
(SETQ %LLL3 (CONS (CAR -X) %LLL3)))
(COND
((NULL -X) (SETQ VAL 'NILL TYP 'UN HYPVAL 'NILL))
((EQ -X T) (SETQ VAL T TYP 'ATOM HYPVAL T))
((NUMBP -X) (SETQ VAL -X TYP 'NUMBP HYPVAL -X))
((ATOM -X)
(COND
((MEMQ -X LABEL))
((NULL (SETQ TYP (GET -X 'TYP)))
(ERREUR 'UNDEFINIE -X)
(SETQ VAL)
(PUT -X 'UN 'TYP)
(SETQ HYPVAL NIL)
(SETQ TYP 'UN))
(T (SETQ
VAL (GET -X 'VAL)
HYPVAL
(OR VAL (GET -X 'HYPVAL) (HYPVAL TYP -X)))
HYPVAL)))
((AND (NULL REC) (EQ (CAR -X) FFN)) (REC (CDR -X)))
((SETQ AUX1 (GET (CAR -X) 'FTN1)) (APPLY AUX1 (CDR -X)))
((LISTP (CAR -X))
(MEVAL (CAR -X))
(INCR PROFO)
(MEVAL (CDR -X)))
((TESTARG -X)))
(AND
(LISTP -X)
(MEMQ (CAR -X)
'(TIMES PLUS ADD1 1+ 1- CONS CDR CDDR CDDDR CAR QUO REM))
(NEXTL %LLL3))
(OR (ZEROP PROFO) (DECR PROFO)))
(DE TEST3 (-X)
(SETQ AUX3)
(ESCAPE EX
(MAPS -X
(FUNCTION (LAMBDA (XX)
(MAPC HELP
(FUNCTION (LAMBDA (Y)
(COND
((ATOM XX))
((OR
(AND LOOPVAR (EQ (CAAR XX) 'RETURN))
(EQUAL (CAR XX) Y)) (EX (SETQ AUX3 T)))
((MEMBER 'QQC (CADDR Y))
(AND
(QQC (CAR XX) Y)
(EX (SETQ AUX3 T)))))))))))))
(DE QQC (-X Y)
(AND
(EQ (CAR -X) (CAR Y))
(EQ (CADR -X) (CADR Y))
(LISTP (CADDR -X))
(EQ (CAR (CADDR -X)) (CAR (CADDR Y)))
(EQ (CADR (CADDR -X)) (CADR (CADDR Y)))))
; wht wht1 ;
(DE WHT (-X Y)
(ESCAPE EX1
(SETQ HELP)
(COND
((ATOM -X)
(SETQ
HELP
[['NEXTL -X]
['SETQ -X ['CDR -X]]
['SETQ -X ['CDDR -X]]]))
((MEMQ (CAR -X) '(GTZ GZP))
(INCR PROFO)
(MEVAL (CADR -X))
(COND
((OR (EQ TYP 'LISTP) (EQ VAL T))
(ERREUR "CA BOUCLE" (CONS 'WHILE (CONS -X Y))))
((NUMBP (CADR -X))
(IF (GZP (CADR -X))
(ERREUR "CA BOUCLE :"
(CONS 'WHILE (CONS -X Y)))
(ERREUR
"VOTRE BOUCLE NE SERA JAMAIS EXECUTEE"
(CONS 'WHILE (CONS -X Y)))))
((LISTP (CADR -X)))
((SETQ HELP (APPLY (GET 'GTZ 'WHT) (CDR -X))))))
((AND (NUMBP (CADR -X)) (NUMBP (CADDR -X)))
(WHT1 -X Y)
(SETQ Y))
((AND (LISTP (CADR -X)) (LISTP (CADDR -X))))
((AND
(OR (NUMBP (CADR -X)) (LISTP (CADR -X)))
(MEMQ (CAR -X) '(GTZ GZP GT LE LT GE)))
(SETQ
HELP (CDR (APPLY (GET (CAR -X) 'WHT) (CDR -X)))))
((OR (NUMBP (CADDR -X)) (LISTP (CADDR -X)))
(SETQ
HELP
(CONS (CAR (APPLY (GET (CAR -X) 'WHT) (CDR -X)))
(CDDR (APPLY (GET (CAR -X) 'WHT) (CDR -X))))))
((SETQ
HELP
(AND
(GET (CAR -X) 'WHT)
(APPLY (GET (CAR -X) 'WHT) (CDR -X))))))
(COND
(HELP
(MAPS Y
(FUNCTION (LAMBDA (YY)
(MAPC HELP
(FUNCTION (LAMBDA (XX)
(COND
((ATOM YY))
((EQ (CAAR YY) 'COND)
(COND
((TEST3 (CDR YY)) (EX1))
(T (ESCAPE EX2
(MAPC (CDAR YY)
(FUNCTION (LAMBDA (XXX)
(AND
(TEST3 XXX)
(EX2))))))
(COND
(AUX3
(SETQ LOOPVAR T)
(MAPC (CDAR YY)
(FUNCTION (LAMBDA
(XXX)
(COND
((AND
(ATOM -X)
(EQUAL
['NULL
-X]
(CAR XXX))) )
((TEST3 XXX) )
((INSERT
(CAR HELP)
XXX)))))))
(T (INSERT1 (CAR HELP)
(IF AUX1
(CONS 'WHILE Y)
(CONS 'WHILE
(CONS -X Y))))))))
(EX1 (SETQ LOOPVAR)))
((MEMBER 'QQC (CADDR XX))
(AND (QQC (CAR YY) XX) (EX1)))
((EQUAL (CAR YY) XX) (EX1)))))))))
(INSERT1 (CAR HELP)
(IF AUX1
(CONS 'WHILE Y)
(CONS 'WHILE (CONS -X Y)))))
((ERREUR 'WHILE
["PEUX PAS VERIFIER VOTRE BOUCLE"
(CONS 'WHILE (CONS -X Y))])))))
(DE WHT1 (-X Y)
(ERREUR
(IF (EVAL -X)
"CA BOUCLE"
"VOTRE BOUCLE NE SERA JAMAIS EXECUTEE")
(CONS 'WHILE (CONS -X Y)))
(EX1))
; nimmarg combc pusc pob ;
(DE NIMMARG (-X Y)
(WHILE (SETQ -X HELP)
(COND
((LISTP (CAR -X))
(COND
((SETQ
AUX1
(AND (ATOM (CAAR -X)) (GET (CAAR -X) 'FTN)))
(APPLY AUX1 (CDAR -X)))
((AND
LCOND
AUX
(OR
(EQ (CAAR -X) T)
(PREDIC (CAAR -X))
(AND
(LISTP (CAAR -X))
(PREDIC (CAR (CAAR -X))))))
(SETQ AUX1 (POB))
(PUSC (CONS (REVERSE AUX) (POB)))
(SETQ AUX)
(PUSC AUX1)
(AND
(EQ (CAAR -X) T)
(SETQ HELP (APPEND (CAR -X) (CDR -X)))))
((LISTP (CAAR -X))
(SETQ
HELP
(IF (EQ (GET (CAAAR -X) 'TYP) 'PREDICAT)
(CONS 'COND -X)
(APPEND (CAR -X) (CDR -X)))))
((SETQ HELP (APPEND (CAR -X) (CDR -X))))))
(T (ERFTN -X Y)))))
(DE COMBC (-X)
(COND
((ATOM -X) (IF (NULL -X) (SETQ VAL 'NILL)) (SETQ AUX1 -X))
((MEMQ (CAR -X) AVANCE) (COMBC (CADR -X)))
((MEMQ (CAR -X) '(SUB1 ADD1)) (COMBC (CADR -X)))
((EQ (CAR -X) 'SETQ) (SETQ AUX1 (COMBC (CADDR -X))))
((EQ (CAR -X) 'CONS) (SETQ VAL T) NIL)))
(DE PUSC (-X) (NEWL STACK -X))
(DE POB () (NEXTL STACK))
; pprin test ;
(DF PPRIN (-X)
(SETQ -X (CDAR -X))
(WHILE -X
(PRINT (NEXTL -X))
(TTAB 10)
(PRIN1 (NEXTL -X))
(TERPRI)))
(DE TEST (-X Y)
(INIT Y)
(WHILE (LISTP (CAR -X)) (SETQ -X (NCONC (CAR -X) (CDR -X))))
(ESCAPE EXIT
(COND
((ATOM -X) (SETQ AUX -X))
((NUMBP (CAR -X)) (TEST (CDR -X)))
((eq (car -x) 'eval)(eprogn (cdr -x)))
((SETQ AUX1 (GET (CAR -X) 'FTN))
(APPLY AUX1 (CDR -X))
(OR (TEST1) (SETQ AUX) (EVAL AUX)))
((MEMQ (CAR -X) F-N-SUBR)
(SETQ HELP -X)
(NIMMARG -X)
(OR (TEST1) (SETQ AUX) (EVAL AUX)))
((SETQ AUX -X)))
(TERPRI)
(COND
(AUX
(PRINT "P R O P O S I T I O N :")
(TERPRI)
(EVAL AUX)
(PRETTYP AUX)))
(PRINT !! '(!? 20) "A PART CA VOTRE FONCTION SEMBLE OK."
!!)))
; eqq ;
(DE EQQ (-X Y)
(COND
((EQUAL -X Y) (INSERT T ['EQ -X Y] T))
(T (INCR PROFO)
(MEVAL Y)
(PUSH VAL TYP)
(INCR PROFO)
(MEVAL -X)
(SELECTQ TYP
(LISTP
(TESTA ['EQ -X Y] 'ARG1 -X "ATOMIQUE" 'LISTP)
(SETQ TYP (POP))
(POP)
(COND
((EQ TYP 'LISTP)
(TESTA ['EQ -X Y] 'ARG2 Y "ATOMIQUE" 'LISTP)
(INSERT ['EQUAL -X Y] ['EQ -X Y] T)
(PRINT "JE CHANGE" !! '(!? 10) ['EQ -X Y]
!! "EN" !! '(!? 10) ['EQUAL -X Y])))
(SETQ VAL 'NILL TYP 'UN HYPVAL 'NILL))
(NUMBP
(COND
((EQ (SETQ TYP (POP)) 'NUMBP)
(COND
(VAL
(COND
((EQ (SETQ HELP (POP)) VAL)
(SETQ TYP 'ATOM VAL T))
((NULL HELP)
(SETQ TYP 'UN VAL NIL))
((SETQ TYP 'UN VAL 'NILL))))
((SETQ TYP 'UN VAL NIL))))
((EQ TYP 'UN)
(AND (ATOM Y) (PUT Y 'NUMBP 'TYP))
(SETQ VAL)
(POP))
((EQ TYP 'LISTP)
(TESTA ['EQ -X Y] 'ARG2 Y "ATOMIQUE" 'LISTP)
(POP)
(SETQ TYP 'UN VAL 'NILL))
((TESTA ['EQ -X Y] 'ARG2 Y "NUMERIQUE"
"ATOMIQUE") (SETQ TYP 'UN VAL 'NILL) (POP))))
((ATOM LITATOM STRINGP)
(COND
((EQ (SETQ TYP (POP)) 'LISTP)
(TESTA ['EQ -X Y] 'ARG2 Y "ATOMIQUE" 'LISTP)
(POP)
(SETQ TYP 'UN VAL 'NILL))
((EQ TYP 'UN)
(AND (ATOM Y) (PUT Y 'ATOM 'TYP))
(SETQ VAL)
(POP))
((EQ TYP 'NUMBP)
(TESTA ['EQ -X Y] 'ARG1 -X "NUMERIQUE"
'ATOM)
(POP)
(SETQ TYP 'UN VAL 'NILL))
(T (SETQ HELP (POP))
(COND
(VAL
(COND
((EQ HELP VAL)
(SETQ TYP 'ATOM VAL T))
(HELP (SETQ TYP 'UN VAL 'NILL))))
((SETQ TYP 'UN VAL NIL))))))
(UN
(COND
((EQ (SETQ TYP (POP)) 'UN) (SETQ VAL) (POP))
(T (POP) (EQQ Y -X))))
(NIL
(PRINT "EQQ ATTENTION D" TYP "!!!! X=" -X "Y=" Y)))))
(OR (ZEROP PROFO) (DECR PROFO)))
; erftn add getarg but unput ;
(DE ERFTN (-X Y)
(COND
((EQ (CAR -X) FFN)
(GETARG (CAR -X) (CDR -X) (GET FFN 'NUMARG))
(PUT FFN 'REC 'TYP))
((MEMQ (CAR -X) F-N-SUBR)
(COND
((SETQ AUX1 (GET (CAR -X) 'FTN))
(NEXTL HELP)
(NEWL FIND T)
(APPLY AUX1 (CDR -X))
(NEXTL FIND))
((SETQ AUX1 (GET (CAR -X) 'NUMARG))
(GETARG (CAR -X) (CDR -X) AUX1))))
((AND LCOND AUX (EQ (CAR -X) T))
(SETQ AUX1 (POB))
(PUSC (CONS (REVERSE AUX) (POB)))
(SETQ AUX)
(PUSC AUX1)
(ADD (NEXTL -X))
(SETQ HELP -X))
((SETQ AUX1 (AEHNLICH (CAR -X)))
(ERFTN (CONS AUX1 (CDR -X)) Y))
((EQ Y 1) (SETQ HELP (CDR -X)) (ADD (CAR -X)))
(T (SETQ HELP (CDR -X))
(NEWL LABEL (ETI (CAR -X)))
(SETQ %LLL2 (CAR -X))
(ADD (ETI (CAR -X)))
(OR Y (ERREUR 2 (CAR -X))))))
(DE ADD (-X) (NEWL AUX -X))
(DE GETARG (CA CD NO A)
(COND
((ZEROP NO) (SETQ HELP CD) (ADD (CONS CA (REVERSE A))))
((LISTP (CAR CD))
(COND
((SETQ
AUX1
(AND (LITATOM (CAAR CD)) (GET (CAAR CD) 'FTN)))
(APPLY AUX1 (CDAR CD))
(SETQ HELP (CDR CD))
(GETARG CA HELP (SUB1 NO) (CONS (NEXTL AUX) A)))
((SETQ AUX1 (AEHNLICH (CAAR CD)))
(SETQ HELP (CONS (CONS AUX1 (CDAR CD)) (CDR CD)))
(GETARG CA HELP NO A))
(T (SETQ HELP (APPEND (CAR CD) (CDR CD)))
(GETARG CA HELP NO A))))
((MEMQ (CAR CD) F-N-SUBR)
(COND
((SETQ AUX1 (GET (CAR CD) 'FTN))
(NEXTL HELP)
(APPLY AUX1 (CDR CD))
(GETARG CA HELP (SUB1 NO) (CONS (NEXTL AUX) A)))
((SETQ AUX1 (GET (CAR CD) 'NUMARG))
(GETARG (CAR CD) (CDR CD) AUX1)
(AND
(EQ (CAR CD) FFN)
(PUT FFN
(CONS (CDAR AUX) (GET FFN 'VAREC))
'VAREC)
(PUT FFN 'REC 'TYP))
(GETARG CA HELP (SUB1 NO) (CONS (NEXTL AUX) A)))))
((SETQ AUX1 (AEHNLICH (CAR CD)))
(GETARG CA (CONS AUX1 (CDR CD)) NO A))
((AND (EQ CA FFN) (NULL CD))
(SETQ AUX1 (CAR (LAST (GET FFN 'DUVAR) NO)))
(PRINT !! "JE SUPPOSE QUE VOUS NE VOULEZ" "PAS CHANGER LE"
(CONCAT (ADD1 (DIFFER (LENGTH (GET FFN 'DUVAR)) NO))
"-IEME ARGUMENT") "DANS"
!! '(!? 10) (CONS CA (REVERSE A)))
(GETARG CA CD (SUB1 NO) (CONS AUX1 A)))
(T (GETARG CA (CDR CD) (SUB1 NO) (CONS (CAR CD) A)))))
(DE BUT (-X Y Z)
(COND
(ICOND
(COND
((OR (EQ (GET -X Z) 'UN) (NULL (GET -X Z)))
(PUT -X Y Z))
(T (NEWL HELP1 -X) (PUSH Z Y) (PUT -X Y Z))))
((PUT -X Y Z))))
(DE UNPUT () (WHILE HELP1 (PUT (NEXTL HELP1) (POP) (POP))))
; kond kondk fsub iprog ;
(DE KOND (-X --Y --Z)
(SETQ AUX2 (CDR (MEMBER (CONS 'COND -X) AUX)))
(NEWL ICOND T)
(NEWL LCOND NIL)
(MAPC -X
(FUNCTION (LAMBDA (XX)
(ESCAPE EX
(AND (NULL (CAR XX)) (EX (DELETE XX)))
(SETQ %LLL2 XX)
(INCR PROFO)
(MEVAL (CAR XX))
(COND
((MEMQ (CAR XX) WHT) (KONDK XX -X))
((AND (EQ (CAR XX) T) (NULL (CADR XX)))
(DELETE XX))
((AND (EQ (CAR XX) T) (EQ (CAR (CADR XX)) 'COND))
(SETQ AUX1 (REVERSE (CDR (CADR XX))))
(INSERT (CAR AUX1) XX T)
(WHILE (CDR AUX1)
(INSERT (CADR AUX1) (NEXTL AUX1) NIL NIL T))
(EX))
((EQ VAL 'NILL)
(PRINT "DANS")
(PRETTYP (CONS 'COND -X))
(PRINT "LA CLAUSE" (CAR XX)
"A DES CHANCES D'ETRE TOUJOURS FAUX")))
(MAPC (CDR XX)
'(LAMBDA (XXX) (INCR PROFO) (MEVAL XXX)))
(SETQ
LCOND (CONS (CONS XX (CAR LCOND)) (CDR LCOND)))
(AND (GZP PROFO) (DECR PROFO))
(MAPC AUX2 'MEVAL)
(UNPUT)))))
(SETQ --Y)
(ESCAPE EX
(MAPC -X
(FUNCTION (LAMBDA (XX)
(IF (NOT (MEMQ FFN (LINEAR XX))) (EX) (SETQ --Y T))))))
(IF (NULL --Y)
NIL
(SETQ --Y NIL --Z NIL)
(MAPC -X
(FUNCTION (LAMBDA (XX)
(IF (MEMQ FFN (LINEAR XX))
(NEWL --Y XX)
(NEWL --Z XX)))))
(INSERT
[(CONS 'COND (APPEND (REVERSE --Z) (REVERSE --Y)))]
(CONS 'COND -X) NIL NIL NIL NIL T))
(NEXTL LCOND)
(NEXTL ICOND))
(DE KONDK (XX -X)
(COND
((CDR (MEMBER XX -X))
(PRINT "LES CLAUSES SUIVANT" !! '(!? 10) XX !!
"NE SERONT JAMAIS UTILISEES : JE LES ENLEVE" !!)
(MAPC (CDR (MEMBER XX -X)) 'DELETE))
((AND
(LISTP (CAR XX))
(MEMQ (CAAR XX) '(SETQ SET RPLACA RPLACD NEXTL))))
((PRINT "PAS BESOIN DE FAIRE LE TEST :" (CAR XX) "DANS" !!
'(!? 10) XX) (INSERT T XX T T))))
(DE FSUB (-X Y)
(PUSC AUX)
(SETQ AUX)
(COND
(FIND (PUSC))
((LISTP (CAR HELP)) (PUSC (CDR HELP)))
(T (PUSC)))
(SETQ HELP -X)
(NIMMARG -X 1)
(SETQ HELP (POB))
(PUSC (CONS Y (REVERSE AUX)))
(SETQ AUX (CADR STACK))
(ADD (POB))
(POB))
(DE IPROG ()
(COND
((ETIQ2 'VARLOC)
(AND REFAV (ERREUR 'GO REFAV))
(AND FFN (PUT FFN VARLOC 'VARLOC))))
(ETIQ1))
; ade errgrave aux aux1 predic ;
(DE ADE ()
(COND
((NULL IPROG)
(COND
((ETIQ2 'FFNVAR)
(AND REFAV (ERREUR 'GO REFAV))
(PUT FFN FFNVAR 'DUVAR)
(PUT FFN (LENGTH FFNVAR) 'NUMARG)))
(AND
(ETIQ1)
(SETQ IPROG T)
(SETQ
AUX
(NCONC [(CAR AUX) (CADR AUX) (CADDR AUX)]
[(CONS 'PROG (CONS NIL (CDDDR AUX)))]))))))
(DE ERRGRAVE (-X Y) (EXIT ['ERRGRAVE -X '--> Y]))
(DE AUX () (PUSC AUX) (PUSC HELP) (SETQ AUX))
(DE AUX1 ()
(SETQ HELP (CDR (POB)))
(SETQ AUX (CONS (REVERSE AUX) (POB))))
(DE PREDIC (-X)
(AND (NOT (MEMQ -X '(OR AND))) (EQ (GET -X 'TYP) 'PREDICAT)))
; aehnlich trr ;
(DE AEHNLICH (-X YY Z)
(IF
(OR
(NUMBP -X)
(LISTP -X)
(EQ -X T)
(NULL -X)
(MEMQ -X F-N-SUBR)
(AND IPROG (MEMQ -X VARLOC))
(AND FFN (MEMQ -X FFNVAR))) (LESCAPE))
(MAPC (IF YY (EVAL YY) F-N-SUBR)
(FUNCTION (LAMBDA (XX)
(COND
((GT (ABS (DIFFER (PLENGTH XX) (PLENGTH -X))) 1))
(T (ESCAPE EXI
(SETQ
AUX1 (EXPLODE XX)
YY (EXPLODE -X)
COMPT 0)
(WHILE (OR AUX1 YY)
(INCR COMPT)
(COND
((EQ (CAR AUX1) (CAR YY))
(NEXTL AUX1)
(NEXTL YY))
((OR
(EQUAL (CDR AUX1) YY)
(EQUAL (CDR YY) AUX1)
(EQUAL (CDR AUX1) (CDR YY))
(AND
(EQ (CADR YY) (CAR AUX1))
(EQ (CAR YY) (CADR AUX1))
(EQUAL (CDDR YY) (CDDR AUX1))))
(ADDPROP 'PROPO XX COMPT)
(EXI))
((EXI))))))))))
(ESCAPE EX
(COND
((NULL (CDR 'PROPO))
(AND Z (EX))
(SETQ
AUX1
(OR
(AEHNLICH -X 'VARLOC T)
(AEHNLICH -X 'FFNVAR T)))
(EX AUX1))
(T (SETQ AUX1)
(MAPC (CDR 'PROPO)
(FUNCTION (LAMBDA (XX)
(AND (NUMBP XX) (SETQ AUX1 (CONS XX AUX1))))))
(COND
((TRR AUX1)
(COND
(%%C
(PRINT '? -X '--> !!)
(RPLACD 'PROPO)
(SETQ AUX1 (READ))
(EX AUX1))
((SETQ
AUX1 (GETALL 'PROPO (APPLY 'MAX AUX1)))
(RPLACD 'PROPO)
(ERRGRAVE -X AUX1))))
((SETQ AUX1 (GET 'PROPO (APPLY 'MAX AUX1)))
(RPLACD 'PROPO)
(ERREUR 'NOM ['? -X '--> AUX1])
(EX AUX1)))))))
(DE TRR (-X Y Z)
(SETQ Y (APPLY 'MAX -X))
(SETQ Z 0)
(WHILE -X (AND (EQ (NEXTL -X) Y) (SETQ Z (ADD1 Z))))
(GT Z 1))
; erreur eti etiq1 etiq2 ervarl ervara varan ;
(DE ERREUR (-X Y) (PRINT "ERREUR:" !! '(!? 10) -X '--> Y))
(DE ETI (-X) (COND
((NUMBP -X) (GENSYM 'A -X))
(T -X)))
(DE ETIQ1 (-X)
(COND
(LABEL
(SETQ AUX1 LABEL)
(WHILE AUX1
(COND
((GET (CAR AUX1) 'AP)
(PUT (CAR AUX1)
(CDR (MEMQ (CAR AUX1) AUX))
'VAL)
(SETQ -X T))
((EQ (LENGTH (MEMQ (CAR AUX1) AUX)) 1))
((SETQ AUX (DELQ (CAR AUX1) AUX))))
(NEXTL AUX1))
-X)))
(DE ETIQ2 (LVAR)
(ESCAPE EX
(COND
(REFAV
(MAPC REFAV
(FUNCTION (LAMBDA (-X)
(COND
((MEMQ -X LABEL)
(SETQ REFAV (DELQ -X REFAV)))
((MEMQ -X (EVAL LVAR))
(SETQ REFAV (DELQ -X REFAV))
(NEWL LABEL -X)
(PUT -X
(IF (EQ LVAR 'FFNVAR)
(CDDDR AUX)
(CDDR AUX))
'VAL)
(RPLACD
(IF (EQ LVAR 'FFNVAR) (CDR AUX) AUX)
(CONS (SET LVAR (DELQ -X (EVAL LVAR)))
(CONS -X
(IF (EQ LVAR 'FFNVAR)
(CDDDR AUX)
(CDDR AUX)))))
(EX T))))))))))
(DE ERVARL (-X)
(COND
((ATOM (CAR -X)) (ERVARA -X))
((ERVARA (APPEND (CAR -X) (CDR -X))))))
(DE ERVARA (-X)
(COND
((NULL (CAR -X)) (SETQ HELP (CDR -X)) NIL)
((ATOM (CAR -X))
(COND
((MEMQ (CAR -X) '(D G L))
(CONS (CAR -X) (ERVARA (CDR -X))))
((MEMQ (CAR -X) F-N-SUBR) (SETQ HELP [-X]) NIL)
((CONS (ETI (CAR -X)) (ERVARA (CDR -X))))))
((OR
(AND (LISTP (CAAR -X)) (MEMQ (CAAAR -X) F-N-SUBR))
(MEMQ (CAAR -X) F-N-SUBR)
(AND
(GT (LENGTH (EXPLODE FFN)) 1)
(AEHNLICH (CAAR -X)))) (SETQ HELP -X) NIL)
((ERVARA (APPEND (CAR -X) (CDR -X))))))
(DE VARAN (-X Y)
(AND
-X
(MAPC -X
(FUNCTION (LAMBDA (XX)
(COND
((OR (MEMQ XX FFNVAR) (MEMQ XX VARLOC))
(ERREUR 1 XX))
((SET Y (CONS XX (EVAL Y)))
(PUT XX 'UN 'TYP)
(PUT XX NIL 'VAL)))))))
(SET Y (REVERSE (EVAL Y))))
; cond0 cond1 cond2 cond3 ;
(DE COND0 (-X)
(AUX)
(SETQ HELP -X)
(WHILE (SETQ -X HELP)
(COND
((LISTP (CAR -X))
(AUX)
(NEWL LCOND T)
(NIMMARG (SETQ HELP (CAR -X)) 1)
(SETQ HELP (CDAR STACK))
(COND2)
(NEXTL LCOND))
(T (COND1 -X))))
(SETQ HELP (POB))
(COND
(FIND (SETQ HELP))
((LISTP (NEXTL HELP)))
((SETQ HELP)))
(ESCAPE EX
(WHILE T
(SETQ -X HELP)
(COND
((LISTP (CAR HELP))
(COND
((OR
(EQ (CAAR -X) T)
(PREDIC (CAAR -X))
(AND
(ATOM (CAAR -X))
(SETQ AUX1 (AEHNLICH (CAAR -X)))
(EQ (GET AUX1 'TYP) 'PREDICAT)
(RPLACA (CAR HELP) AUX1))
(AND
(LISTP (CAAR -X))
(OR
(EQ (GET (CAR (CAAR -X)) 'TYP)
'PREDICAT)
(AND
(SETQ
AUX1 (AEHNLICH (CAR (CAAR -X))))
(EQ (GET AUX1 'TYP) 'PREDICAT)
(RPLACA (CAAR HELP) AUX1)))))
(AUX)
(NEWL LCOND T)
(NIMMARG (SETQ HELP (CAR HELP)) 1)
(SETQ HELP (CDAR STACK))
(COND2)
(NEXTL LCOND))
(T (EX))))
((AND (EQ (CAR HELP) T) (NEQ (CAAR AUX) T))
(SETQ
HELP
(CONS [(CAR HELP) (CADR HELP)] (CDDR HELP))))
((GT (LENGTH (CAR AUX)) 1) (EX))
((MEMQ (CAR HELP) LABEL) (EX))
((OR (NULL HELP) (NULL (CAR HELP))) (EX))
((NOT
(OR
(MEMQ (CAR HELP) F-N-SUBR)
(MEMQ (AEHNLICH (CAR HELP)) F-N-SUBR)))
(RPLACA AUX (CONS (CAR AUX) (CONS (CAR HELP))))
(NEXTL HELP))
(T (EX)))))
(SETQ -X (SETQ AUX1))
(WHILE AUX
(COND
((NULL (CAAR AUX)) (NEXTL AUX))
((OR (NUMBP (CAAR AUX)) (EQ (CAAR AUX) T))
(SETQ -X (CONS (NEXTL AUX) -X)))
(T (SETQ AUX1 (CONS (NEXTL AUX) AUX1)))))
(SETQ
AUX
(CONS
(CONS 'COND
(APPEND AUX1
(COND
((GT (LENGTH -X) 1)
(PRINT "ERREUR :" !! "IL Y A TROP DES CLAUSES"
"CONSTANTES : " -X)
(LAST -X))
(-X)))) (POB))))
(DE COND1 (-X)
(AUX)
(POB)
(ERFTN -X 1)
(ESCAPE EXX
(WHILE HELP
(COND
((LISTP (CAR HELP))
(COND
((OR
(LISTP (SETQ AUX1 (CAAR HELP)))
(EQ AUX1 T)
(NUMBP AUX1)
(PREDIC AUX1)) (EXX))
((SETQ AUX1 (GET (CAAR HELP) 'NUMARG))
(IF (GT AUX1 3)
(APPLY (GET (CAAR HELP) 'FTN)
(CDAR HELP))
(ERFTN (NCONC (CAR HELP) (CDR HELP)) 1)))
((SETQ HELP (APPEND (CAR HELP) (CDR HELP))))))
((NUMBP (CAR HELP)) (ADD (CAR HELP)) (NEXTL HELP))
((OR
(PREDIC (CAR HELP))
(PREDIC (AEHNLICH (CAR HELP)))
(AND (CDR HELP) (EQ (CAR HELP) T))) (EXX))
(T (ERFTN HELP 1)))))
(SETQ AUX (CONS (REVERSE AUX) (POB))))
(DE COND2 ()
(COND
((GT (LENGTH AUX) 1) (AUX1))
((COND3 HELP) (AUX1))
((AND (EQ (CAR HELP) T) (NOT (COND3 (CDR HELP)))) (AUX1))
(T (POB)
(PUSC (REVERSE AUX))
(PUSH (CDR HELP))
(SETQ AUX)
(NIMMARG (SETQ HELP (CONS (CAR HELP))) 1)
(SETQ
HELP (POP)
AUX (CONS (APPEND (POB) (REVERSE AUX)) (POB))))))
(DE COND3 (-X)
(AND
(LISTP (CAR -X))
(OR
(LISTP (SETQ AUX1 (CAAR -X)))
(EQ AUX1 T)
(PREDIC (SETQ AUX1 (OR (AEHNLICH AUX1) AUX1)))
(MEMQ AUX1 VARLOC)
(MEMQ AUX1 FFNVAR))))
; getall finconv find1 find2 hypval null1 caddar ;
(DE GETALL (AT IND)
(MAPT (CDR AT)
(FUNCTION (LAMBDA (-X) (AND (EQ (CAR -X) IND) (CADR -X))))))
(DE FINCONV () (SETQ %%C))
(DE FIND1 (-X Y)
(MAPS Y
(FUNCTION (LAMBDA (XX)
(COND
((ATOM XX))
((AND
(EQ (CAAR (CDR XX)) 'SETQ)
(EQ (CADR (CADR XX)) -X))
(SETQ AUX1 (CADR XX) AUX4 (CDDR XX) AUX3 XX)))))))
(DE FIND2 (-X)
(ESCAPE EX
(MAPC AUX
(FUNCTION (LAMBDA (XX)
(COND
((EQ (CAR XX) 'COND) NIL)
((EQUAL XX -X) (EX -X))
(T (MAPS XX
(FUNCTION (LAMBDA (XXX)
(COND
((ATOM XXX))
((EQUAL (CAR XXX) -X) (EX XX)))))))))))))
(DE HYPVAL (TYP -X)
(SETQ
HYPVAL
(SELECTQ TYP
(NUMBP 7)
(LISTP [(GENSYM) (GENSYM) (GENSYM)])
(ATOM (GENSYM))
(UN
(OR
(HYPVAL
(GET (CAR %LLL3)
(IF (BOUNDP 'YY) (CAR YY) 'ARG1)) -X)))
(NIL)))
(COND
((ATOM -X)
(BUT -X HYPVAL 'HYPVAL)
(IF (NULL (GET -X 'INITHYP)) (PUT -X HYPVAL 'INITHYP))))
HYPVAL)
(DE NULL1 (-X) (IF (EQ -X 'NILL) T 'NILL))
(DE CADDAR (-X) (CADDR (CAR -X)))
; delete insert insert1 test1 test2 ;
(DE DELETE (-X -Y)
(ESCAPE EX
(MAPS (OR -Y AUX)
(FUNCTION (LAMBDA (-XX)
(COND
((ATOM -XX))
((EQUAL (CADR -XX) -X)
(EX (RPLACD -XX (CDDR -XX))))))))))
(DE INSERT (-X APR YY ZZ WW VV UU)
(ESCAPE EX
(MAPS (OR VV AUX)
(FUNCTION (LAMBDA (-XX)
(COND
((ATOM -XX))
((AND
UU
(EQUAL (CADR -XX) APR)
(EX (RPLACD -XX -X))))
((EQUAL (CAR -XX) APR)
(COND
(WW (EX (ATTACH -X -XX)))
(ZZ (EX (RPLACA (CAR -XX) -X)))
(YY (EX (RPLACA -XX -X)))
((EX (ATTACH -X (CDAR -XX))))))))))))
(DE INSERT1 (-X APR)
(ESCAPE EX
(MAPS AUX
(FUNCTION (LAMBDA (-XX)
(COND
((ATOM -XX))
((EQUAL (CAR -XX) APR)
(EX (NCONC (CAR -XX) [-X])))))))))
(DE TEST1 ()
(PRINT !! !! (IF (EQ TEST1 1)
"AMELIORATIONS DE SURFACE :"
(CONCAT "PROPOSITION " (SUB1 TEST1) " :")) !!)
(AND (LISTP (CAR AUX)) (SETQ AUX (CAR AUX)))
(PRETTYP AUX)
(PUSH (SUBST NIL NIL AUX))
(TERPRI)
(MAPC '(LCOND REFAV %LLL1 %LLL2 FIND) 'SET)
(AND
(SETQ AUX1 (GET (CAR AUX) 'FTN1))
(APPLY AUX1 (CDR AUX)))
(IF (EQUAL AUX (POP)) NIL (TEST2)))
(DE TEST2 ()
(PUSH (SUBST NIL NIL AUX))
(APPLY (GET (CAR AUX) 'FTN1) (CDR AUX))
(IF (EQUAL AUX (POP)) T (TEST2)))
; PHENAR---- ;
(DE PHENARETEFILE (FILO FILI)
(ESCAPE &eof
(DE EOF ()
(INPUT)
(OUTPUT)
(REMPROP 'EOF 'EXPR)
(&eof filo))
(OUTPUT FILO)
(INPUT FILI)
(WHILE T
(PHENARETES (PRINT (READ)))
(SPACES 10)
(PRINC '* 40)
(TERPRI))))))))
(DE PHENARETES (-X) (TEST -X))
(DF PHENARETE (-X)
(WHILE -X
(INIT)
(SETQ AUX1 (GET (CAR -X) 'EXPR))
(COND
((NULL AUX1)
(PRINT !! !! "JE NE PEUT COMPRENDRE QUE DES EXPRS :"
!! (NEXTL -X) "N'EN FAIT PAS PARTIE"))
((SETQ AUX1 (CONS 'DE (CONS (NEXTL -X) (CDR AUX1))))
(TERPRI)
(PUSH AUX1)
(PRETTYP AUX1)
(ESCAPE EXIT
(APPLY (GET 'DE 'FTN) (CDR AUX1))
(APPLY (GET 'DE 'FTN1) (CDR AUX)))
(COND
((EQUAL (POP) AUX)
(PRINT !! '(!? 20) "VOTRE FONCTION SEMBLE OK.")
(EVAL AUX))
(T (MAPC '(P R O P O S I T I O N :) 'PRIN1)
(TEST2)
(EVAL AUX)
(PRETTYP AUX)
(PRINT !! '(!? 20)
" A PART CA VOTRE FONCTION SEMBLE OK.")
(TERPRI)))))))
; rec -rec4 com ;
(DE REC (-X)
(ESCAPE EX
(OR
ICOND
(EX
(INSERT
['COND [T (SETQ AUX1 (FIND2 (CONS FFN -X)))]] AUX1
T)))
(MAPC -X '(LAMBDA (XX) (INCR PROFO) (MEVAL XX)))
(SETQ AUX1 -X)
(ESCAPE EXX (REC1 -X))
(OR REC (REC2))
(OR
REC
(AND (-REC4 -X) (OR (REC -X) T))
(COM (CONS FFN -X))))
(SETQ REC))
(DE -REC4 (-X -XXX)
(ESCAPE -EXX
(WHILE -X
(IF
(AND
(ATOM (CAR -X))
(MEMQ (CAR -X) (GET FFN 'DUVAR))
(MEMQ (SETQ -XXX (GET (CAR -X) 'TYP))
'(NUMBP LISTP)))
(-EXX
(RPLACA -X
[(SELECTQ -XXX
(NUMBP 'SUB1)
(LISTP 'CDR)
(NIL))
(CAR -X)])))
(NEXTL -X))))
(DE COM (-X)
(PRINT
"JE NE PEUT PAS ENCORE VERIFIER VOTRE APPEL RECURSIF :" !!
'(!? 10) -X))
; meval2 rec1 shorter longer greater smaller ;
(DE MEVAL2 (-X XX Y)
(COND
((EQ (CADR -X) XX) (SETQ MODIF Y))
((LISTP (CADR -X))
(MEVAL1 (CADR -X) XX)
(SELECT MODIF
(Y T)
((SETQ MODIF))))))
(DE REC1 (-X)
(MAPC (GET FFN 'DUVAR)
(FUNCTION (LAMBDA (XX)
(ESCAPE EX
(PUT XX (CONS (CAR AUX1) (GET XX 'VAREC)) 'VAREC)
(SETQ MODIF)
(MEVAL1 (NEXTL AUX1) XX)
(OR MODIF (EX))
(SET XX MODIF)
(COND
((ATOM MODIF) (FIND (MODIF XX)))
(T (MAPC MODIF
'(LAMBDA (XXX)
(FIND (XXX XX))
(COND
(REC (SET XX XXX) (EXX))))))))
(AND REC (EXX))))))
(DE SHORTER (-X)
[['NULL -X]
['LT ['LENGTH -X] QQC]
['LE ['LENGTH -X] QQC]
['EQ ['LENGTH -X] QQC]])
(DE LONGER (-X)
[['GT ['LENGTH -X] QQC]
['GE ['LENGTH -X] QQC]
['EQ ['LENGTH -X] QQC]])
(DE GREATER (-X) [['GT -X QQC] ['GE -X QQC] ['EQ -X QQC]])
(DE SMALLER (-X)
[['LE -X 0]
['ZEROP -X]
['LT -X QQC]
['LE -X QQC]
['EQ -X QQC]])
; meval1 ;
(DE MEVAL1 (-X XX)
(IF (ATOM -X)
NIL
(SELECTQ (CAR -X)
((CDR CDDR CAR CAAR)
(COND
((NULL MODIF) (MEVAL2 -X XX 'SHORTER))
(T (SELECTQ MODIF
(SHORTER T)
((SETQ MODIF))))))
(CONS
(COND
((NULL MODIF)
(COND
((EQ (CADDR -X) XX) (SETQ MODIF 'LONGER))
((LISTP (CADDR -X))
(MEVAL1 (CADDR -X) XX)
(SELECTQ MODIF
((LONGER SHORTER) T)
((SETQ MODIF))))))))
(SUB1
(COND
((NULL MODIF) (MEVAL2 -X XX 'SMALLER))
(T (SELECTQ MODIF
(SMALLER T)
((SETQ MODIF))))))
(ADD1
(COND
((NULL MODIF) (MEVAL2 -X XX 'GREATER))
(T (SELECTQ MODIF
(GREATER T)
((SETQ MODIF))))))
((PRINT PRIN1) (MEVAL1 (CADR -X) XX))
(PLUS
(COND
((NULL MODIF)
(COND
((MEMQ XX (CDR -X)) (SETQ MODIF 'GREATER))
(T (ESCAPE EX
(MAPC (CDR -X)
'(LAMBDA (XXX)
(MEVAL1 XXX XX)
(COND
((EQ MODIF 'GREATER) (EX T))
((EQ MODIF 'SMALLER)
(EX
(SETQ
MODIF
['GREATER
'SMALLER])))
((MEMQ 'GREATER MODIF)
(EX T))
((SETQ MODIF)))))))))
(T (SELECTQ MODIF
(GREATER T)
(SMALLER (SETQ MODIF [MODIF 'SMALLER]))
((SETQ MODIF))))))
(NIL))))
; find rec2 rec22 rec3 gettyp insert2 ;
(DE FIND (-X -Y)
(MAPC -X
(FUNCTION (LAMBDA (XX)
(MAPC (OR -Y (CAR LCOND))
(FUNCTION (LAMBDA (XXX)
(MAPS XXX
(FUNCTION (LAMBDA (YY)
(AND
(OR
(EQ (LENGTH (CAR YY)) 2)
(AND
(EQ (LENGTH (CAR YY)) 3)
(MEMQ QQC XX)))
(EQ (CAR XX) (CAAR YY))
(EQUAL (CADR XX) (CADR (CAR YY)))
(EXX (SETQ REC T)))))))))))))
(DE REC2 (YY)
(PUSH (SUBST NIL NIL AUX))
(ESCAPE EXX (REC22))
(COND
(REC
(SETQ YY (POP))
(PUSH (SUBST NIL NIL AUX))
(SETQ AUX YY)
(MAPC %%1 '(LAMBDA (XX) (PUSH (EVAL XX))))
(PUSH (CDR FFN))
(MAPC (GET FFN 'DUVAR) '(LAMBDA (XX) (PUSH (CDR XX))))
(REC3)
(AND REC (INCR TEST1) (TEST AUX T))
(MAPC (REVERSE (GET FFN 'DUVAR))
'(LAMBDA (XX) (RPLACD XX (POP))))
(RPLACD FFN (POP))
(MAPC (REVERSE %%1) '(LAMBDA (XX) (SET XX (POP))))
(SETQ AUX (POP)))
(T (POP) (REC3))))
(DE REC22 (Z ZZ)
(MAPC (CAR LCOND)
(FUNCTION (LAMBDA (-X)
(COND
((NULL (SETQ ZZ (GETTYP (CAR -X)))))
((OR
(NULL (CAR (LAST -X)))
(NUMBP (CAR (LAST -X)))
(AND
(LISTP (CAR (LAST -X)))
(EQ (CAAR (LAST -X)) QUOTE))))
((ATOM (SETQ Z (CAR (LAST -X))))
(SELECTQ ZZ
((SMALLER SHORTER)
(COND
((MEMQ (CAR Z) '(LONGER GREATER)))
((EQ (CAR Z) ZZ)
(MAPC (GET FFN 'DUVAR)
(FUNCTION (LAMBDA (XX)
(COND
((MEMQ (CAR XX) '(LONGER GREATER))
(RPLACA (LAST -X) XX)
(EXX (SETQ REC T))))))))))
((SETQ REC)))))))))
(DE REC3 (Z -XX)
(ESCAPE EXX
(MAPC (GET FFN 'DUVAR)
(FUNCTION (LAMBDA (-X)
(COND
((OR
(EQ (CAR -X) 'SHORTER)
(EQ (CAR -X) 'SMALLER))
(SETQ Z (CAR ((CAR -X) -X)))
(FIND [Z] AUX)
(INSERT2 (SETQ -XX
[Z
(OR
(ESCAPE EX
(MAPC (GET FFN 'DUVAR)
'(LAMBDA (XX)
(AND
(MEMQ (CAR XX)
'(LONGER GREATER))
(EX XX)))))
(AND %LLL3 (GET (CAR %LLL3) 'NEUTRE)))]))
(SETQ LCOND (CONS (CONS -XX (CAR LCOND))
(CDR LCOND)))
(EXX (SETQ REC T)))))))))
(DE GETTYP (-X Z -XX -Y)
(ESCAPE EX
(COND
((ATOM -X))
(T (SELECTQ (CAR -X)
((NULL ZEROP)
(IF (EQ (CAR -X) 'NULL)
(SETQQ -XX SHORTER -Y (CAR CDR CADR CDDR CAAR CADDR))
(SETQQ -XX SMALLER -Y (ADD1 SUB1)))
(COND
((OR
(ATOM (SETQ Z (CADR -X)))
(AND
(MEMQ (CAADR -X) -Y)
(ATOM (SETQ Z (CADADR -X)))))
(COND
((EQ (CAR Z) -XX) -XX)
(T (MAPC (GET FFN 'DUVAR)
(FUNCTION (LAMBDA (XX)
(AND
(EQ (CAR XX) -XX)
(SETQ Z (SUBST XX Z -X))
(INSERT Z -X T)
(EX -XX))))))))))
(NIL))))))
(DE INSERT2 (-X)
(ESCAPE EX
(MAPS AUX
(FUNCTION (LAMBDA (XX)
(COND
((ATOM XX))
((EQUAL (CAR XX) %LLL2) (EX (ATTACH -X XX)))))))))
(PROGN
(STATUS 1 1 2)
(SETQ PHENAR '(DSK (PHENAR . VLI)))
'(LOAD : PHENARETE PHENARETES PHENARETEFILE))
; END OF FILE : (DSK (PHE . VLI) NIL) 3-Aug-78 02:03:42 ;